home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 44 / PC Actual CD 44.iso / Linux / Cygwin / full.exe / Disk1 / data1.cab / Tools / share / tix4.1 / Control.tcl < prev    next >
Encoding:
Text File  |  1998-12-04  |  12.0 KB  |  479 lines
  1. # Control.tcl --
  2. #
  3. #     Implements the TixControl Widget. It is called the "SpinBox"
  4. #     in other toolkits.
  5. #
  6. # Copyright (c) 1996, Expert Interface Technologies
  7. #
  8. # See the file "license.terms" for information on usage and redistribution
  9. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  10. #
  11.  
  12. tixWidgetClass tixControl {
  13.     -classname  TixControl
  14.     -superclass tixLabelWidget
  15.     -method {
  16.     incr decr invoke update
  17.     }
  18.     -flag {
  19.     -allowempty -autorepeat -command -decrcmd -disablecallback
  20.     -disabledforeground -incrcmd -initwait -integer -llimit
  21.     -repeatrate -max -min -selectmode -step -state -validatecmd
  22.     -value -variable -ulimit
  23.     }
  24.     -forcecall {
  25.     -variable -state
  26.     }
  27.     -configspec {
  28.     {-allowempty allowEmpty AllowEmpty false}
  29.     {-autorepeat autoRepeat AutoRepeat true}
  30.     {-command command Command ""}
  31.     {-decrcmd decrCmd DecrCmd ""}
  32.     {-disablecallback disableCallback DisableCallback 0 tixVerifyBoolean}
  33.     {-disabledforeground disabledForeground DisabledForeground #303030}
  34.     {-incrcmd incrCmd IncrCmd ""}
  35.     {-initwait initWait InitWait 500}
  36.     {-integer integer Integer false}
  37.     {-max max Max ""}
  38.     {-min min Min ""}
  39.     {-repeatrate repeatRate RepeatRate 50}
  40.     {-step step Step 1}
  41.     {-state state State normal}
  42.     {-selectmode selectMode SelectMode normal}
  43.     {-validatecmd validateCmd ValidateCmd ""}
  44.     {-value value Value 0}
  45.     {-variable variable Variable ""}
  46.     }
  47.     -alias {
  48.     {-llimit -min}
  49.     {-ulimit -max}
  50.     }
  51.     -default {
  52.     {.borderWidth             0}
  53.     {*entry.relief            sunken}
  54.     {*entry.width            5}
  55.     {*label.anchor            e}
  56.     {*label.borderWidth        0}
  57.     {*Label.font                   -Adobe-Helvetica-Bold-R-Normal--*-120-*}
  58.     {*Button.anchor            c}
  59.     {*Button.borderWidth        2}
  60.     {*Button.highlightThickness    1}
  61.     {*Button.takeFocus        0}
  62.     {*Entry.background        #c3c3c3}
  63.     }
  64. }
  65.  
  66. proc tixControl:InitWidgetRec {w} {
  67.     upvar #0 $w data
  68.  
  69.     tixChainMethod $w InitWidgetRec
  70.  
  71.     set data(varInited)      0
  72.     set data(serial)    0
  73. }
  74.  
  75. proc tixControl:ConstructFramedWidget {w frame} {
  76.     upvar #0 $w data
  77.  
  78.     tixChainMethod $w ConstructFramedWidget $frame
  79.  
  80.     set data(w:entry)  [entry $frame.entry]
  81.  
  82.     set data(w:incr) [button $frame.incr -bitmap [tix getbitmap incr] \
  83.     -takefocus 0]
  84.     set data(w:decr) [button $frame.decr -bitmap [tix getbitmap decr] \
  85.     -takefocus 0]
  86.  
  87. #    tixForm $data(w:entry) -left 0 -top 0 -bottom -1 -right $data(w:decr) 
  88. #    tixForm $data(w:incr) -right -1 -top 0 -bottom %50
  89. #    tixForm $data(w:decr) -right -1 -top $data(w:incr) -bottom -1
  90.  
  91.     pack $data(w:entry) -side left   -expand yes -fill both
  92.     pack $data(w:decr)  -side bottom -fill both -expand yes
  93.     pack $data(w:incr)  -side top    -fill both -expand yes
  94.  
  95.     $data(w:entry) delete 0 end
  96.     $data(w:entry) insert 0 $data(-value)
  97.  
  98.     # This value is used to configure the disable/normal fg of the ebtry
  99.     set data(entryfg) [$data(w:entry) cget -fg]
  100.     set data(labelfg) [$data(w:label) cget -fg]
  101. }
  102.  
  103. proc tixControl:SetBindings {w} {
  104.     upvar #0 $w data
  105.  
  106.     tixChainMethod $w SetBindings
  107.  
  108.     bind $data(w:incr) <ButtonPress-1> \
  109.       [format {after idle tixControl:StartRepeat %s  1} $w]
  110.     bind $data(w:decr) <ButtonPress-1> \
  111.       [format {after idle tixControl:StartRepeat %s  -1} $w]
  112.  
  113.     # These bindings will stop the button autorepeat when the 
  114.     # mouse button is up
  115.     foreach btn "$data(w:incr) $data(w:decr)" {
  116.     bind $btn <ButtonRelease-1> "tixControl:StopRepeat $w"
  117.     }
  118.  
  119.     tixSetMegaWidget $data(w:entry) $w
  120.  
  121.     # If user press <return>, verify the value and call the -command
  122.     #
  123.     tixAddBindTag $data(w:entry) TixControl:Entry 
  124. }
  125.  
  126. proc tixControlBind {} {
  127.     tixBind TixControl:Entry <Return> {
  128.     tixControl:Invoke [tixGetMegaWidget %W] 1
  129.     }
  130.     tixBind TixControl:Entry <Escape> {
  131.     tixControl:Escape [tixGetMegaWidget %W]
  132.     }
  133.     tixBind TixControl:Entry <Up> {
  134.     [tixGetMegaWidget %W] incr
  135.     }
  136.     tixBind TixControl:Entry <Down> {
  137.     [tixGetMegaWidget %W] decr
  138.     }
  139.     tixBind TixControl:Entry <FocusOut> {
  140.     if {"%d" == "NotifyNonlinear" || "%d" == "NotifyNonlinearVirtual"} {
  141.         tixControl:Tab [tixGetMegaWidget %W] %d
  142.     }
  143.     }
  144.     tixBind TixControl:Entry <Any-KeyPress> {
  145.     tixControl:KeyPress [tixGetMegaWidget %W]
  146.     }
  147.     tixBind TixControl:Entry <Any-Tab> {
  148.     # This has a higher priority than the <Any-KeyPress>  binding
  149.     # --> so that data(edited) is not set
  150.     }
  151. }
  152.  
  153. #----------------------------------------------------------------------
  154. #                           CONFIG OPTIONS
  155. #----------------------------------------------------------------------
  156. proc tixControl:config-state {w arg} {
  157.     upvar #0 $w data
  158.  
  159.     if {$arg == "normal"} {
  160.     $data(w:incr)  config -state $arg
  161.     $data(w:decr)  config -state $arg
  162.     catch {
  163.         $data(w:label) config -fg $data(labelfg)
  164.     }
  165.     $data(w:entry) config -state $arg -fg $data(entryfg)
  166.     } else {
  167.     $data(w:incr)  config -state $arg
  168.     $data(w:decr)  config -state $arg
  169.     catch {
  170.         $data(w:label) config -fg $data(-disabledforeground)
  171.     }
  172.     $data(w:entry) config -state $arg -fg $data(-disabledforeground)
  173.     }
  174. }
  175.  
  176. proc tixControl:config-value {w value} {
  177.     upvar #0 $w data
  178.  
  179.     tixControl:SetValue $w $value 0 1
  180.  
  181.     # This will tell the Intrinsics: "Please use this value"
  182.     # because "value" might be altered by SetValues
  183.     #
  184.     return $data(-value)
  185. }
  186.  
  187. proc tixControl:config-variable {w arg} {
  188.     upvar #0 $w data
  189.  
  190.     if [tixVariable:ConfigVariable $w $arg] {
  191.        # The value of data(-value) is changed if tixVariable:ConfigVariable 
  192.        # returns true
  193.        tixControl:SetValue $w $data(-value) 1 1
  194.     }
  195.     catch {
  196.     unset data(varInited)
  197.     }
  198.     set data(-variable) $arg
  199. }
  200.  
  201. #----------------------------------------------------------------------
  202. #                         User Commands
  203. #----------------------------------------------------------------------
  204. proc tixControl:incr {w {by 1}} {
  205.     upvar #0 $w data
  206.  
  207.     if {$data(-state) != "disabled"} {
  208.     if {[catch {$data(w:entry) index sel.first}] == 0} {
  209.         $data(w:entry) select from end
  210.         $data(w:entry) select to   end
  211.     }
  212.     # CYGNUS LOCAL - why set value before changing it?
  213.     #tixControl:SetValue $w [$data(w:entry) get] 0 1
  214.     tixControl:AdjustValue $w $by
  215.     }
  216. }
  217.  
  218. proc tixControl:decr {w {by 1}} {
  219.     upvar #0 $w data
  220.  
  221.     if {$data(-state) != "disabled"} {
  222.     if {[catch {$data(w:entry) index sel.first}] == 0} {
  223.         $data(w:entry) select from end
  224.         $data(w:entry) select to   end
  225.     }
  226.     # CYGNUS LOCAL - why set value before changing it?
  227.     #tixControl:SetValue $w [$data(w:entry) get] 0 1
  228.     tixControl:AdjustValue $w [expr 0 - $by]
  229.     }
  230. }
  231.  
  232. proc tixControl:invoke {w} {
  233.     upvar #0 $w data
  234.  
  235.     tixControl:Invoke $w 0
  236. }
  237.  
  238. proc tixControl:update {w} {
  239.     upvar #0 $w data
  240.  
  241.     if [info exists data(edited)] {
  242.     tixControl:invoke $w
  243.     }
  244. }
  245.  
  246. #----------------------------------------------------------------------
  247. #                       Internal Commands
  248. #----------------------------------------------------------------------
  249.  
  250. # Change the value by a multiple of the data(-step)
  251. #
  252. proc tixControl:AdjustValue {w amount} {
  253.     upvar #0 $w data
  254.  
  255.     if {$amount == 1 && $data(-incrcmd) != ""} {
  256.     set newValue [tixEvalCmdBinding $w $data(-incrcmd) "" $data(-value)]
  257.     } elseif {$amount == -1 && $data(-decrcmd) != ""} {
  258.     set newValue [tixEvalCmdBinding $w $data(-decrcmd) "" $data(-value)]
  259.     } else {
  260.     set newValue [expr $data(-value) + $amount * $data(-step)]
  261.     }
  262.  
  263.     if {$data(-state) != "disabled"} {
  264.     tixControl:SetValue $w $newValue 0 1
  265.     }
  266. }
  267.  
  268. proc tixControl:SetValue {w newvalue noUpdate forced} {
  269.     upvar #0 $w data
  270.  
  271.     if {[$data(w:entry) selection present]} {
  272.     set oldSelection \
  273.         "[$data(w:entry) index sel.first] [$data(w:entry) index sel.last]"
  274.     }
  275.  
  276.     set oldvalue $data(-value)
  277.     set oldCursor [$data(w:entry) index insert]
  278.     set changed 0
  279.  
  280.  
  281.     if {$data(-validatecmd) != ""} {
  282.     # Call the user supplied validation command
  283.     #
  284.        set data(-value) [tixEvalCmdBinding $w $data(-validatecmd) "" $newvalue]
  285.     } else {
  286.     # Here we only allow int or floating numbers
  287.     #
  288.     # If the new value is not a valid number, the old value will be
  289.     # kept due to the "catch" statements
  290.     #
  291.     if [catch {expr 0+$newvalue}] {
  292.         set newvalue 0
  293.         set data(-value) 0
  294.         set changed 1
  295.     }
  296.  
  297.     if {$newvalue == ""} {
  298.         if {![tixGetBoolean -nocomplain $data(-allowempty)]} {
  299.         set newvalue 0
  300.         set changed 1
  301.         } else {
  302.         set data(-value) ""
  303.         }
  304.     }
  305.  
  306.     if {$newvalue != ""} {
  307.         # Change this to a valid decimal string (trim leading 0)
  308.         #
  309.         regsub {^[0]*} $newvalue "" newvalue
  310.         if [catch {expr 0+$newvalue}] {
  311.         set newvalue 0
  312.         set data(-value) 0
  313.         set changed 1
  314.         }
  315.         if {$newvalue == ""} {
  316.         set newvalue 0
  317.         }
  318.  
  319.         if [tixGetBoolean -nocomplain $data(-integer)] {
  320.         set data(-value) [tixGetInt -nocomplain $newvalue]
  321.         } else {
  322.         if [catch {set data(-value) [format "%d" $newvalue]}] {
  323.             if [catch {set data(-value) [expr $newvalue+0.0]}] {
  324.             set data(-value) $oldvalue
  325.             }
  326.         }
  327.         }
  328.         
  329.         # Now perform boundary checking
  330.         #
  331.         if {$data(-max) != "" && $data(-value) > $data(-max)} {
  332.         set data(-value) $data(-max)
  333.         }
  334.         if {$data(-min) != "" && $data(-value) < $data(-min)} {
  335.         set data(-value) $data(-min)
  336.         }
  337.     }
  338.     }
  339.  
  340.     if {! $noUpdate} {
  341.     tixVariable:UpdateVariable $w
  342.     }
  343.  
  344.     if {$forced || "x$newvalue" != "x$data(-value)" || $changed} {
  345.     $data(w:entry) delete 0 end
  346.     $data(w:entry) insert 0 $data(-value)
  347.     $data(w:entry) icursor $oldCursor
  348.     if {[info exists oldSelection]} {
  349.         eval $data(w:entry) selection range $oldSelection
  350.     }
  351.     }
  352.  
  353.     if {!$data(-disablecallback) && $data(-command) != ""} {
  354.     if {![info exists data(varInited)]} {
  355.         set bind(specs) ""
  356.         tixEvalCmdBinding $w $data(-command) bind $data(-value)
  357.     }
  358.     }
  359. }
  360.  
  361. proc tixControl:Invoke {w forced} {
  362.     upvar #0 $w data
  363.  
  364.     catch {
  365.     unset data(edited)
  366.     }
  367.  
  368.     if {[catch {$data(w:entry) index sel.first}] == 0} {
  369.     # THIS ENTRY OWNS SELECTION --> TURN IT OFF
  370.     #
  371.     $data(w:entry) select from end
  372.     $data(w:entry) select to   end
  373.     }
  374.  
  375.     tixControl:SetValue $w [$data(w:entry) get] 0 $forced
  376. }
  377.  
  378. #----------------------------------------------------------------------
  379. # The three functions StartRepeat, Repeat and StopRepeat make use of the
  380. # data(serial) variable to discard spurious repeats: If a button is clicked
  381. # repeatedly but is not hold down, the serial counter will increase
  382. # successively and all "after" time event handlers will be discarded
  383. #----------------------------------------------------------------------
  384. proc tixControl:StartRepeat {w amount} {
  385.     if {![winfo exists $w]} {
  386.     return
  387.     }
  388.  
  389.     upvar #0 $w data
  390.  
  391.     incr data(serial)
  392.     # CYGNUS LOCAL bug fix
  393.     # Need to set a local variable because otherwise the buttonrelease
  394.     # callback could change the value of data(serial) between now and
  395.     # the time the repeat is scheduled.
  396.     set serial $data(serial)
  397.  
  398.     if {[catch {$data(w:entry) index sel.first}] == 0} {
  399.     $data(w:entry) select from end
  400.     $data(w:entry) select to   end
  401.     }
  402.  
  403.     if [info exists data(edited)] {
  404.     unset data(edited)
  405.     tixControl:SetValue $w [$data(w:entry) get] 0 1
  406.     }
  407.  
  408.     tixControl:AdjustValue $w $amount
  409.  
  410.     if {$data(-autorepeat)} {
  411.     after $data(-initwait) tixControl:Repeat $w $amount $serial
  412.     }
  413.  
  414.     focus $data(w:entry)
  415. }
  416.  
  417. proc tixControl:Repeat {w amount serial} {
  418.     if {![winfo exists $w]} {
  419.     return
  420.     }
  421.     upvar #0 $w data
  422.  
  423.     if {$serial == $data(serial)} {
  424.     tixControl:AdjustValue $w $amount
  425.  
  426.     if {$data(-autorepeat)} {
  427.        after $data(-repeatrate) tixControl:Repeat $w $amount $serial
  428.     }
  429.     }
  430. }
  431.  
  432. proc tixControl:StopRepeat {w} {
  433.     upvar #0 $w data
  434.  
  435.     incr data(serial)
  436. }
  437.  
  438. proc tixControl:Destructor {w} {
  439.  
  440.     tixVariable:DeleteVariable $w
  441.  
  442.     # Chain this to the superclass
  443.     #
  444.     tixChainMethod $w Destructor
  445. }
  446.  
  447. # ToDo: maybe should return -code break if the value is not good ...
  448. #
  449. proc tixControl:Tab {w detail} {
  450.     upvar #0 $w data
  451.  
  452.     if {![info exists data(edited)]} {
  453.     return
  454.     } else {
  455.     unset data(edited)
  456.     }
  457.  
  458.     tixControl:invoke $w
  459. }
  460.  
  461. proc tixControl:Escape {w} {
  462.     upvar #0 $w data
  463.  
  464.     $data(w:entry) delete 0 end
  465.     $data(w:entry) insert 0 $data(-value)
  466. }
  467.  
  468. proc tixControl:KeyPress {w} {
  469.     upvar #0 $w data
  470.  
  471.     if {$data(-selectmode) == "normal"} {
  472.     set data(edited) 0
  473.     return
  474.     } else {
  475.     # == "immediate"
  476.     after 1 tixControl:invoke $w
  477.     }
  478. }
  479.